home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Doc / Isotas96 / mop.stk < prev    next >
Encoding:
Text File  |  1996-01-16  |  5.6 KB  |  171 lines
  1. ;;;;
  2. ;;;; {\bf Utilities}
  3. ;;;;
  4. (define make-tk-name 
  5.   (lambda (parent)
  6.     (gensym (format #f "~A.v" (if (eq? parent *root*) "" (Id parent))))))
  7.  
  8. (define split-options
  9.   (lambda (valid-slots initargs)
  10.     (letrec 
  11.         ((separate 
  12.           (lambda (valids args tk-opt other)
  13.             (if (null? args)
  14.                 (cons tk-opt other)
  15.                 (if (member (car args) valids)
  16.                     (separate valids (cddr args)
  17.                               (list* (car args) (cadr args) tk-opt)
  18.                               other)
  19.                     (separate valids (cddr args)
  20.                               tk-opt 
  21.                               (list* (car args) (cadr args) other)))))))
  22.       (separate valid-slots initargs '() '()))))
  23.  
  24. ;;;;
  25. ;;;; {\bf Simple widgets}
  26. ;;;;
  27. ;; 
  28. ;; <Tk-metaclass> class definition and associated methods
  29. ;;
  30. (define-class <Tk-Metaclass> (<class>)
  31.   ((valid-options :accessor Tk-valid-options)))
  32.  
  33.  
  34. (define-method initialize ((class <Tk-Metaclass>) initargs)
  35.   (next-method)
  36.   ;; Build a list of allowed keywords. These keywords will be passed to
  37.   ;; the Tk-command at build time
  38.   (let ((slots        (slot-ref class 'slots))
  39.         (res         '())
  40.         (tk-virtual?  (lambda(s) 
  41.                         (eqv? (get-slot-allocation s) :tk-virtual))))
  42.     (for-each (lambda (s)
  43.                 (when (tk-virtual? s)
  44.                   (let ((key (make-keyword (car s))))
  45.                     (set! res (cons key res)))))
  46.               slots)
  47.     ;; Store this list in the new allocated class
  48.     (set! (Tk-valid-options class) res)))
  49.  
  50.  
  51. (define-method compute-get-n-set ((class <Tk-Metaclass>) slot)
  52.   (if (eqv? (get-slot-allocation slot) :tk-virtual)
  53.       ;; this is a Tk-virtual slot
  54.       (let ((opt (make-keyword (car slot))))
  55.         (list (lambda (o)   (list-ref ((Id o) 'configure opt) 4))
  56.               (lambda (o v) ((Id o) 'configure opt v))))
  57.       ;; call super compute-get-n-set
  58.       (next-method)))
  59.  
  60. ;;
  61. ;; Basic virtual classes for widgets: <Tk-object>, <Tk-widget> and 
  62. ;; <Tk-simple-widget>
  63. ;;
  64. (define-class <Tk-object> ()
  65.   ((Id      :accessor Id)                             ;; Widget Id
  66.    (parent  :accessor parent :init-keyword :parent))) ;; Parent widget
  67.  
  68. (define-class <Tk-widget> (<Tk-object>)
  69.   ())
  70.  
  71.  
  72.  
  73. (define-class <Tk-simple-widget> (<Tk-widget>)
  74.   ;; Each widget has at least the slot bg for its background colour
  75.   ((bg :accessor bg :init-keyword :bg :allocation :tk-virtual))
  76.   :metaclass <Tk-Metaclass>)
  77.  
  78.  
  79. (define-method initialize ((self <Tk-simple-widget>) initargs)
  80.   ;; Use split-options on initargs to separate STklos slots 
  81.   ;; from Tk ones. Set parent to the root window if not specified
  82.   ;; in initargs
  83.   (let* ((options (split-options (Tk-valid-options (class-of self))
  84.                  initargs))
  85.          (parent  (get-keyword :parent (cdr options) *root*)))
  86.     ;; Call the Tk command which creates the widget
  87.     (set! (Id self) (apply (tk-constructor self)
  88.                            (make-tk-name parent) 
  89.                            (car options)))
  90.     ;; Initialize other slots (i.e. non Tk-virtual ones)
  91.     (next-method self (cdr options))))
  92.  
  93.  
  94. ;;
  95. ;; We can now define three widget classes: <Label>, <Button> and <Canvas>
  96. ;; as well as their associated Tk-command
  97. ;;
  98. (define-class <Label> (<Tk-simple-widget>)
  99.   ((font :accessor font :init-keyword :font :allocation :tk-virtual)
  100.    (text :accessor text :init-keyword :text :allocation :tk-virtual)))
  101.  
  102. (define-class <Button> (<Label>)
  103.   ((command :accessor command :init-keyword :command 
  104.         :allocation :tk-virtual)))
  105.  
  106. (define-class <Canvas> (<Tk-simple-widget>)
  107.   ())
  108.  
  109. (define-method tk-constructor ((self <Label>))  label)
  110. (define-method tk-constructor ((self <Button>)) button)
  111. (define-method tk-constructor ((self <Canvas>)) canvas)
  112.  
  113.  
  114. ;;;;
  115. ;;;; {\bf Canvas items widgets}
  116. ;;;;
  117. ;; 
  118. ;; <Tk-item-metaclass> class definition and associated methods  
  119. ;; 
  120.  
  121. (define-class <Tk-item-metaclass> (<Tk-Metaclass>)
  122.   ())
  123.  
  124. (define-method compute-get-n-set ((class <Tk-item-metaclass>) slot)
  125.   (if (eqv? (get-slot-allocation slot) :tk-virtual)
  126.       ;; this is a Tk-virtual slot
  127.       (let ((opt (make-keyword (car slot))))
  128.         (list (lambda (obj)   
  129.         (list-ref ((Id obj) 'itemconfigure (Cid obj) opt) 4))
  130.               (lambda (obj val) 
  131.         ((Id obj) 'itemconfigure (Cid obj) opt val))))
  132.       ;; call super compute-get-n-set
  133.       (next-method)))
  134.  
  135. ;;
  136. ;; Basic virtual class: <Tk-canvas-item> 
  137. ;;
  138. (define-class <Tk-canvas-item> (<Tk-object>)
  139.   ((Cid :accessor  Cid)
  140.    (width :accessor width :allocation :tk-virtual))
  141.   :metaclass <Tk-item-metaclass>)
  142.  
  143.  
  144. (define-method initialize ((self <Tk-canvas-item>) initargs)
  145.   (let* ((options (split-options (Tk-valid-options (class-of self))
  146.                  initargs))
  147.          (parent  (get-keyword :parent (cdr options) #f))
  148.          (coords  (get-keyword :coords (cdr options) #f)))
  149.     (if (not (and parent coords))
  150.     (error "Parent widget and coordinates must be given!!"))
  151.     (set! (Id  self) (Id parent))
  152.     (set! (CId self) (apply (Id parent) 
  153.                             'create
  154.                             (canvas-item-initializer self)
  155.                             (append coords (car options))))
  156.     ;; Initialize other slots (i.e. non Tk-virtual ones)
  157.     (next-method self (cdr options))))
  158.  
  159. ;;
  160. ;; We can now define two canvas item classes: <Line> and <Rectangle>
  161. ;; as well as their associated initializer
  162. ;;
  163. (define-class <Line>      (<Tk-canvas-item>)
  164.   ())
  165.  
  166. (define-class <Rectangle> (<Tk-canvas-item>)
  167.   ((fill  :accessor fill :init-keyword :fill :allocation :tk-virtual)))
  168.  
  169. (define-method canvas-item-initializer ((self <Rectangle>)) "rectangle")
  170. (define-method canvas-item-initializer ((self <Line>))      "line")
  171.